home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Library-2.01 / extended-loop.lisp next >
Encoding:
Text File  |  1993-09-16  |  5.2 KB  |  129 lines  |  [TEXT/CCL2]
  1. ;;;   -*- Mode: LISP; Syntax: Common-lisp; Package: ANSI-LOOP; Base: 10; Lowercase:T -*-
  2. ;;;>
  3. ;;;> Portions of LOOP are Copyright (c) 1986 by the Massachusetts Institute of Technology.
  4. ;;;> All Rights Reserved.
  5. ;;;> 
  6. ;;;> Permission to use, copy, modify and distribute this software and its
  7. ;;;> documentation for any purpose and without fee is hereby granted,
  8. ;;;> provided that the M.I.T. copyright notice appear in all copies and that
  9. ;;;> both that copyright notice and this permission notice appear in
  10. ;;;> supporting documentation.  The names "M.I.T." and "Massachusetts
  11. ;;;> Institute of Technology" may not be used in advertising or publicity
  12. ;;;> pertaining to distribution of the software without specific, written
  13. ;;;> prior permission.  Notice must be given in supporting documentation that
  14. ;;;> copying distribution is by permission of M.I.T.  M.I.T. makes no
  15. ;;;> representations about the suitability of this software for any purpose.
  16. ;;;> It is provided "as is" without express or implied warranty.
  17. ;;;> 
  18. ;;;>      Massachusetts Institute of Technology
  19. ;;;>      77 Massachusetts Avenue
  20. ;;;>      Cambridge, Massachusetts  02139
  21. ;;;>      United States of America
  22. ;;;>      +1-617-253-1000
  23. ;;;>
  24. ;;;> Portions of LOOP are Copyright (c) 1989, 1990, 1991, 1992 by Symbolics, Inc.
  25. ;;;> All Rights Reserved.
  26. ;;;> 
  27. ;;;> Permission to use, copy, modify and distribute this software and its
  28. ;;;> documentation for any purpose and without fee is hereby granted,
  29. ;;;> provided that the Symbolics copyright notice appear in all copies and
  30. ;;;> that both that copyright notice and this permission notice appear in
  31. ;;;> supporting documentation.  The name "Symbolics" may not be used in
  32. ;;;> advertising or publicity pertaining to distribution of the software
  33. ;;;> without specific, written prior permission.  Notice must be given in
  34. ;;;> supporting documentation that copying distribution is by permission of
  35. ;;;> Symbolics.  Symbolics makes no representations about the suitability of
  36. ;;;> this software for any purpose.  It is provided "as is" without express
  37. ;;;> or implied warranty.
  38. ;;;> 
  39. ;;;> Symbolics, CLOE Runtime, and Minima are trademarks, and CLOE, Genera,
  40. ;;;> and Zetalisp are registered trademarks of Symbolics, Inc.
  41. ;;;>
  42. ;;;>      Symbolics, Inc.
  43. ;;;>      8 New England Executive Park, East
  44. ;;;>      Burlington, Massachusetts  01803
  45. ;;;>      United States of America
  46. ;;;>      +1-617-221-1000
  47.  
  48. ;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49. ;;;
  50. ;;; Modification History
  51. ;;;
  52. ;;; 04/28/93 mwp Release
  53. ;;; 03/19/93 bill eval-when around package definition
  54. ;;;
  55.  
  56. (in-package :ansi-loop)
  57.  
  58.  
  59. #+Cloe-Runtime                    ;Don't ask.
  60. (car (push "%Z% %M% %I% %E% %U%" system::*module-identifications*))
  61.  
  62.  
  63. ;;; The following code could be used to set up the SYMBOLICS-LOOP package
  64. ;;; as it is expected to be.  At Symbolics, in both Genera and CLOE, the
  65. ;;; package setup is done elsewhere.   
  66.  
  67.  
  68. #-Symbolics
  69. (eval-when (:compile-toplevel :execute :load-toplevel)
  70.   (unless (find-package 'symbolics-loop)
  71.     (make-package 'symbolics-loop :use nil))
  72.   
  73.   (import 'ansi-loop::loop-finish (find-package 'symbolics-loop))
  74.  
  75.   (export '(symbolics-loop::loop
  76.             symbolics-loop::loop-finish
  77.             symbolics-loop::define-loop-iteration-path
  78.             symbolics-loop::define-loop-sequence-path
  79.             )
  80.       (find-package 'symbolics-loop))
  81. )
  82.  
  83.  
  84.  
  85. ;;;This is our typical "extensible" universe, which should be a proper superset of the ansi universe.
  86. (defvar *loop-default-universe* (make-ansi-loop-universe t))
  87.  
  88.  
  89.  
  90.  
  91.  
  92.  
  93.  
  94.  
  95. (defmacro symbolics-loop:define-loop-iteration-path (path-name function
  96.                              &key alternate-names preposition-groups
  97.                              inclusive-permitted user-data (loop-universe '*loop-default-universe*))
  98.   `(eval-when (eval compile load)
  99.      (add-loop-path '(,path-name ,@alternate-names) ,function ,loop-universe
  100.             :preposition-groups ',preposition-groups
  101.             :inclusive-permitted ',inclusive-permitted
  102.             :user-data ',user-data)))
  103.  
  104.  
  105. (defmacro symbolics-loop:define-loop-sequence-path (path-name-or-names fetch-function size-function
  106.                             &optional sequence-type element-type)
  107.   "Defines a sequence iteration path.  PATH-NAME-OR-NAMES is either an
  108. atomic path name or a list of path names.  FETCHFUN is a function of
  109. two arguments, the sequence and the index of the item to be fetched.
  110. Indexing is assumed to be zero-origined.  SIZEFUN is a function of
  111. one argument, the sequence; it should return the number of elements in
  112. the sequence.  SEQUENCE-TYPE is the name of the data-type of the
  113. sequence, and ELEMENT-TYPE is the name of the data-type of the elements
  114. of the sequence."
  115.   `(eval-when (eval compile load)
  116.      (add-loop-path ',path-name-or-names 'loop-sequence-elements-path *loop-default-universe*
  117.             :preposition-groups '((:of :in) (:from :downfrom :upfrom) (:to :downto :below :above) (:by))
  118.             :inclusive-permitted nil
  119.             :user-data '(:fetch-function ,fetch-function
  120.                  :size-function ,size-function
  121.                  :sequence-type ,sequence-type
  122.                  :element-type ,element-type))))
  123.  
  124.  
  125. (defmacro symbolics-loop:loop (&environment env &rest keywords-and-forms)
  126.   #+Genera (declare (compiler:do-not-record-macroexpansions)
  127.             (zwei:indentation . zwei:indent-loop))
  128.   (loop-standard-expansion keywords-and-forms env *loop-default-universe*))
  129.